home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
gui140.zip
/
GUI140.BAS
< prev
next >
Wrap
BASIC Source File
|
1997-06-28
|
8KB
|
310 lines
'GUI140.BAS
'GUI Library v. 1.40
'for QuickBasic 4.5
'Copyright (c) 1995 - 1997 by Tika Carr
'
'Special Instructions:
'
'Load QuickBasic from DOS:
'qb /ah /l qb.qlb
'
'See Documentation GUI.DOC for instructions on what to do with this file.
'$INCLUDE: 'gui.bi'
'$DYNAMIC
FUNCTION button$ (x%, y%, t$, bc%, tc%, hl%, cp%, flag%)
mouse "hide"
DIM h$(1 TO 4)
a = x% + LEN(t$) * 8 + 14: B = y% + 18
h$(1) = HEX$(x%): h$(2) = HEX$(y%): h$(3) = HEX$(a): h$(4) = HEX$(B)
IF cp% < 1 THEN cp% = 1
IF flag% = 1 THEN drwbtn 2, bc%, 0, 0, x%, y%, a, B
x% = x% + 8: IF cp% > 1 THEN x% = x% + 2
y% = y% + 2
gprint LEFT$(t$, cp% - 1), x% - 2, y%, tc%
x% = x% + (cp% - 1) * 8
gprint MID$(t$, cp%, 1), x%, y%, hl%
gprint RIGHT$(t$, LEN(t$) - cp%), x% + 8, y%, tc%
mouse "show"
'calculate return value string
FOR i = 1 TO 4
IF LEN(h$(i)) < 2 THEN temp$ = temp$ + "0"
IF LEN(h$(i)) < 3 THEN temp$ = temp$ + "0"
temp$ = temp$ + h$(i)
NEXT
IF flag% THEN temp$ = temp$ + "1" ELSE temp$ = temp$ + "0" 'button or not
button$ = temp$
END FUNCTION
SUB clrscrn (clr%)
mouse "hide"
LINE (0, 0)-(639, 479), clr%, BF
mouse "show"
END SUB
SUB drwbtn (ds, dc, dfs, dfc, dx1, dy1, dx2, dy2)
'Add new style: "Plain" Window (plain with colored non-3d border)
mouse "hide"
IF ds >= 3 AND ds <= 6 THEN c = dfc ELSE c = dc
IF ds < 9 THEN LINE (dx1, dy1)-(dx2, dy2), white%, BF
IF ds > 8 THEN
CIRCLE (dx1, dy1), dfs, white%
PAINT (dx1, dy1), white%, white%
END IF
SELECT CASE ds
CASE 1: GOSUB dOn
CASE 2: GOSUB dOff
CASE 3: GOSUB dOn: GOSUB Inside: GOSUB dOff
CASE 4: GOSUB dOff: GOSUB Inside: GOSUB dOn
CASE 5: GOSUB dOn: GOSUB Inside: GOSUB dOn
CASE 6: GOSUB dOff: GOSUB Inside: GOSUB dOff
CASE 7: GOSUB Dsqu
CASE 8:
GOSUB Dsqu: LINE (dx1, dy1)-(dx2, dy2), black%: LINE (dx1, dy2)-(dx2, dy1), black%
CASE 9: GOSUB Dcir
CASE 10: GOSUB Dcir: CIRCLE (dx1, dy1), (15 - dfs) \ 2, dfc: PAINT (dx1, dy1), dfc, dfc
END SELECT
GOTO Ddone
Dsqu:
LINE (dx1, dy1)-(dx2, dy2), black%, B: PAINT (dx2 - 4, dy2 - 4), c, black%
RETURN
DBold:
GOSUB Dsqu: LINE (dx1 + 1, dy1 + 1)-(dx2 - 1, dy2 - 1), black%, B
RETURN
dOn:
GOSUB DBold: LINE (dx1 + 1, dy2 - 1)-(dx2 - 1, dy2 - 1), white%
LINE -(dx2 - 1, dy1 + 1), white%
RETURN
dOff:
GOSUB DBold: LINE (dx1 + 1, dy2 - 1)-(dx1 + 1, dy1 + 1), white%
LINE -(dx2 - 1, dy1 + 1), white%
RETURN
Dcir:
CIRCLE (dx1, dy1), dfs, black%: PAINT (dx1, dy1), dc, black%
RETURN
Inside:
dx1 = dx1 + dfs: dy1 = dy1 + dfs: dx2 = dx2 - dfs: dy2 = dy2 - dfs: c = dc
RETURN
Ddone: dx1 = dx1 - dfs: dy1 = dy1 - dfs: dx2 = dx2 + dfs: dy2 = dy2 + dfs
mouse "show"
END SUB
SUB gprint (z$, x%, y%, c%)
'This routine was written by Douglas Lusher
mouse "hide"
Regs.ax = &H1130: Regs.bx = &H600: CALL INTERRUPTX(&H10, Regs, Regs)
CharSegment% = Regs.es: CharOffset% = Regs.bp: CharWid% = 8: CharHgt% = 16
DEF SEG = CharSegment%: XX% = x
FOR Char% = 1 TO LEN(z$)
Ptr% = CharHgt% * ASC(MID$(z$, Char%, 1)) + CharOffset%
FOR Ln% = 0 TO CharHgt% - 1
BitPattern& = PEEK(Ptr% + Ln%) * 256&
LineFormat% = (BitPattern& - 32768) XOR -32768
LINE (XX%, y + Ln%)-STEP(CharWid% - 1, 0), c, , LineFormat%
NEXT
XX% = XX% + CharWid%
NEXT
DEF SEG
mouse "show"
END SUB
SUB ImgBuff (x1%, y1%, x2%, y2%, flag%) STATIC
mouse "hide"
'** Save Buffer code
IF flag% = 0 THEN
'Calculate array
Array% = 4 + INT(((x2% - x1% + 1) * 1 + 7) / 8) * 4 * ((y2% - y1%) + 1)
'Check for array size too large and end program if out of bounds
IF Array% > 32767 OR Array% < 0 THEN ERROR 1
REDIM ImBuf(1 TO Array%)
GET (x1%, y1%)-(x2%, y2%), ImBuf
END IF
'** Load buffer code
IF flag% = 1 THEN PUT (x1%, y1%), ImBuf, PSET 'Illegal Function Call here
mouse "show"
END SUB
SUB mouse (a$)
a$ = LCASE$(a$)
SELECT CASE a$
CASE "init": Inregs.ax = 0
CASE "show": Inregs.ax = 1
CASE "hide": Inregs.ax = 2
CASE "get": Inregs.ax = 3
CASE ELSE: Inregs.ax = 0
END SELECT
INTERRUPT &H33, Inregs, Outregs
mb = Outregs.bx 'button 0 = off 1 = left 2 = right
mx = Outregs.cx 'x coordinate
my = Outregs.dx 'y coordinate
END SUB
FUNCTION PopInp$ (p$, l%, x%, y%, bc%, tc%, fc%, ft%, cc%)
c$ = CHR$(219): t$ = "" 'Set cursor and temp variable
'** Draw box and print prompt
IF LEN(p$) > l% THEN x2 = x% + (LEN(p$) + 2) * 8 ELSE x2 = x% + (l% + 2) * 8
a = x%: B = y%
ImgBuff x%, y%, x2, y% + 64, 0 'Save screen under box
drwbtn 2, bc%, 0, 0, x%, y%, x2, y% + 64
x% = x% + 8: gprint p$, x%, y% + 8, tc%
'** Set up input field
y% = y% + 32 'Move down to input line
gprint ">", x%, y%, tc%: x% = x% + 8
gprint STRING$(l%, 219), x%, y%, fc% 'Input Field
gprint c$, x%, y%, cc% 'Cursor
'** Process input
DO
e$ = INPUT$(1): d = ASC(e$)
IF d = 13 THEN EXIT DO
'** check for valid characters & within field
IF d < 128 AND d > 32 AND LEN(t$) < l% THEN
t$ = t$ + e$ 'add character
gprint c$, x%, y%, fc% 'erase cursor
gprint e$, x%, y%, ft% 'print character
x% = x% + 8: gprint c$, x%, y%, cc% 'print cursor
ELSEIF d = 8 AND LEN(t$) > 0 THEN 'backspace pressed
t$ = RIGHT$(t$, LEN(t$) - 1): x% = x% - 8 'remove character from input
gprint CHR$(219), x%, y%, fc% 'erase character
gprint CHR$(219), x% + 8, y%, bc% 'erase cursor
gprint c$, x%, y%, cc% 'place cursor
END IF
LOOP
'** Replace screen (popup done), show mouse and return input
ImgBuff a, B, 0, 0, 1
PopInp$ = t$
END FUNCTION
SUB PopUpBox (x, y, clrbox, clrbdr, clrtext, TextArray$())
NumLines = UBOUND(TextArray$) 'Get # of lines
y2 = NumLines * 8 + 16 'Calculate the maximum Y value
'Look at TextArray and get maximum X value
Tmp1 = 0: Tmp2 = 0
FOR i = 1 TO NumLines
Tmp1 = LEN(TextArray$(i)): IF Tmp1 > Tmp2 THEN x2 = Tmp1
Tmp2 = Tmp1
NEXT
x1 = x: y1 = y: x2 = x1 + x2 * 8 + 40: y2 = y1 + y2 + NumLines * 8 + 32
'x2 above fixes "end of line" bug - hopefully
'y2 allows for more space between text and button
ImgBuff x1, y1, x2, y2, 0 'Save screen underneath
'Draw the box
drwbtn 4, clrbox, 4, clrbdr, x1, y1, x2, y2
tx = x1 + 16: ty = y1 + 8
'Insert Text
FOR i = 1 TO NumLines
gprint TextArray$(i), tx, ty, clrtext: ty = ty + 16
NEXT
'button$ (x%, y%, t$, bc%, tc%, hl%, cp%)
PopOk$ = button$(x1 + ((x2 - x1) \ 2) - 16, ty + 12, "OK", 7, black%, black%, 0, 1)
DO
mouse "get"
IF mb = 1 THEN
OK = pushbtn%(PopOk$)
IF OK = 1 THEN OK = 0: EXIT DO
END IF
LOOP
'Restore Screen
ImgBuff x1, y1, 0, 0, 1
END SUB
FUNCTION pushbtn% (byte$)
'** get values and adjust
x = VAL("&H" + LEFT$(byte$, 3)) + 1
y = VAL("&H" + MID$(byte$, 4, 3)) + 1
a = VAL("&H" + MID$(byte$, 7, 3)) - 1
B = VAL("&H" + MID$(byte$, 10, 3)) - 1
pb = VAL("&H" + MID$(byte$, 13, 1))
IF mx < x OR mx > a OR my < y OR my > B THEN
pushbtn% = 0
EXIT FUNCTION
END IF
'** If its a button, push it
IF pb THEN
mouse "hide"
LINE (x, y)-(a, B), black%, B
LINE (x, B)-(a, B), white%
LINE -(a, y), white%
FOR delay& = 1 TO 32000: NEXT
LINE (x, y)-(a, B), white%, B
LINE (x, B)-(a, B), black%
LINE -(a, y), black%
mouse "show"
END IF
pushbtn% = 1
END FUNCTION
SUB TitleBar (t$, bc%, tc%)
drwbtn 2, bc%, 0, 0, 0, 0, 639, 24
gprint t$, (40 - LEN(t$) \ 2) * 8, 5, tc%
END SUB